#!/usr/bin/perl -w

#
# Copyright (c) 2008, Stuart Simpson-Biles
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#   * Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#   * Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
# FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
# COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#

use strict;
use Getopt::Long;
use LWP::Simple;
use XML::Simple;
use XML::Parser;

# Turn on/off printing of TGM Subject, Format and Subdivision entries
my $print_subj                  = 1;
my $print_form                  = 1;
my $print_subd                  = 1;
# Experimental feature for printing out metadata pertaining to a keyword - not really supported in Lightroom
my $print_meta                  = 0;

# Retrieve XML direct from Library of Congress Website
my $tgm_url                     = 'http://www.loc.gov/rr/print/tgm1/tgm1.xml';
my $do_access_loc               = 0;

# Print out a keyword as a parent to all ones subsequently found
my $print_base_keyword          = 1;
my $base_keyword_string         = "TGM";

# Check for duplicate DESCRIPTOR names in input
my $do_duplicate_check          = 1;
my $die_on_duplicate_descriptor = 0;

my $help = 0;

my $usage = "
#
# Usage
# ~~~~~
# 
# $0 [OPTIONS] <input_file> [<output_file>]
#
# Output is to STDOUT if no <output_file> specified.
#
# Options
# ~~~~~~~
# --[no]subj                           Print TGM Subject 'Subj' fields. Default is to print.
# --[no]form                           Print TGM Format 'Form' fields. Default is to print.
# --[no]subd                           Print TGM Subdivision 'Subd' fields. Default is to print.
# --download                           Download the TGM XML file prior to processing. The downloaded
#                                      data will be written to <input_file> for future use.
# --download_url=s                     URL for the XML file to download. 
#                                      Default is $tgm_url.
# --help                               Print this usage info.
#
# Notes
# ~~~~~
#
# Converts the Thesaurus for Graphic Material (TGM) XML file available from the 
# Library of Congress Website:
#    http://lcweb2.loc.gov/pp/tgmhtml/tgmabt.html
# 
# Into a TAB formatted format suitable for Adobe Lightroom.
#
# The XML file is available for download here:
#    http://www.loc.gov/rr/print/tgm1/downloadtgm1.html
#
# Field description of TGM XML file is located here:
#    http://lcweb2.loc.gov/pp/tgmhtml/tgmdata.html
#
# The script locates all 'DESCRIPTOR' entries in the XML tree and prints them 
# hierarchically, following narrower term ('NT') fields in the 'DESCRIPTOR' 
# entries. Additionally, use for ('UF') fields are output as synonyms for 
# the relevant descriptor.
#
# Examples
# ~~~~~~~~
#
# Download XML into 'in.xml', and output processed Lightroom keywords to 
# out.txt. Omit 'Subd' and 'Form' entries in output:
#
#    $0 --nosubd --noform --download in.xml out.txt
#
# Read 'in.xml' and write full data to 'out.txt':
#
#    $0 in.xml out.txt
# 
";

my $args_ok = GetOptions(
    'subj!'               => \$print_subj,
    'form!'               => \$print_form,
    'subd!'               => \$print_subd,
    'help'                => \$help,
# Direct access to LoC
    'download'            => \$do_access_loc,
    'download_url:s'      => \$tgm_url,

# Less common options
    'duplicate_check!'    => \$do_duplicate_check,
    'print_base_keyword!' => \$print_base_keyword,
    'meta!'               => \$print_meta,
    );

if (!$args_ok || $help ) { PrintUsage(); }

if ($#ARGV < 0) {
    print STDERR "No input file specified. $#ARGV\n\n";
    PrintUsage();
}

my $infile = shift @ARGV;

# Optionally download XML file from the LoC URL. This is placed in a file to facilitate
# caching for future runs.
if ($do_access_loc) {
    print STDERR "Downloading XML [URL:$tgm_url]...";
    open (TMP, '>', $infile) or die "Couldn't open $infile for writing downloaded XML!";
    my $data = get ($tgm_url);
    print TMP $data;
    close (TMP);
    print STDERR "Download complete.\n";
}

if (! -f $infile) {
    print STDERR "Input file not found.\n\n";
    PrintUsage()
};

my $xs1 = XML::Simple->new(ForceArray => ['NT', 'UF']);
my $doc = $xs1->XMLin($infile);

my $outfile = '>-'; # STDOUT output by default
if ($#ARGV >= 0) {
    $outfile = shift @ARGV;
}

open (OUT, '>', $outfile) or die "Couldn't open output file for writing!";
# Lightroom needs UTF-8 to handle special characters in keyword input file
binmode(OUT, ":utf8");

# Sanity check no repeated DESCRIPTOR strings
if ($do_duplicate_check) {
    my $err = 0;
    foreach my $a (@{$doc->{CONCEPT}}) {
	if (exists($a->{DESCRIPTOR})) {
	    my $d = $a->{DESCRIPTOR};
	    my $c = 0;
	    foreach my $b (@{$doc->{CONCEPT}}) {
		if (exists($b->{DESCRIPTOR})) {
		    if ($b->{DESCRIPTOR} eq $d) { 
			$c++; 
		    }
		}
	    }
	    if ($c > 1) { $err=1;}
	}
    }
    if ($err) {
	print STDERR "WARNING: Found duplicate DESCRIPTOR entries!\n";
	die if $die_on_duplicate_descriptor;
    }
}

# Level of indentation
my $level = 0;

# Print a top level category to group all the TGM data into
if ($print_base_keyword) {
	PrintIndentedString("$base_keyword_string\n", $level);
	$level++;
}

# Go through all entries in XML file, look for entries with a "DESCRIPTOR"
# field and print out each one without a "BT" field (indicating that this 
# entry is at the root of the tree).
foreach my $e (@{$doc->{CONCEPT}}) {
    if (exists($e->{DESCRIPTOR})) {
	if (!exists($e->{BT})) {
	    if (
		($print_subj && exists($e->{TTCSubj})) ||
		($print_form && exists($e->{TTCForm})) ||
		($print_subd && exists($e->{TTCSubd}))
		)
	    {
		PrintDescriptor($e->{DESCRIPTOR},$level);
	    }
	}
    }
}

close (OUT);

1;

# Print out a descriptor for a keyword at a given tab depth. Print out
# synonyms and child (narrower term, 'NT') keywords indented a further
# level.
sub PrintDescriptor {
    my ($d, $depth) = @_;
    my $entry = GetDescriptor($d);
    my $i;
	
    if (defined($entry)) {
	my $str = $entry->{DESCRIPTOR};

	PrintIndentedString($str, $depth);
	# Print out "UF" entries as synonyms (tabbed+1, in {})
	if (exists($entry->{UF})) {
	    foreach my $uf (@{$entry->{UF}}) {
		PrintIndentedString("{". $uf . "}", $depth+1);
	    }
	}
	
	# Indent one level and print out all "NT" entries
	if (exists($entry->{NT})) {
	    foreach my $nt (@{$entry->{NT}}) {
		PrintDescriptor($nt, $depth+1);
	    }
	}

	# Experimental, output metadata related to keyword in a child
	# named <<meta>>. Not useful currently as metadata is just
	# treated as child keywords by Lightroom, rather than metadata
	# that could be displayed in a tooltip box etc.
	if ($print_meta) {
	    PrintIndentedString("<<meta>>", $depth+1);
	    if (exists($entry->{Facet})) {
		$str = $entry->{Facet};
		chomp($str);
		PrintIndentedString("Facet: " . $str, $depth+2);
	    }
	    if (exists($entry->{SN})) {
		$str = $entry->{SN};
		chomp($str);
		PrintIndentedString("SN: " . $str, $depth+2);
	    }
	    if (exists($entry->{FUN})) {
		$str = $entry->{FUN};
		chomp($str);				
		PrintIndentedString("FUN: " . $str, $depth+2);
	    }
	    if (exists($entry->{CN})) {
		$str = $entry->{CN};
		chomp($str);			
		PrintIndentedString("CN: " . $str, $depth+2);
	    }
	    if (exists($entry->{TTCSubj})) {
		$str = $entry->{TTCSubj};
		chomp($str);			
		PrintIndentedString( $str, $depth+2);
	    }
	    if (exists($entry->{TTCSubd})) {
		$str = $entry->{TTCSubd};
		chomp($str);			
		PrintIndentedString($str, $depth+2);
	    }
	    if (exists($entry->{TTCForm})) {
		$str = $entry->{TTCForm};
		chomp($str);			
		PrintIndentedString($str, $depth+2);
	    }
	}
    }
}

sub PrintIndentedString {
    my ($str, $depth) = @_;
    my $i;
    for ($i=0;$i<$depth;$i++) {
	print OUT "\t";
    }
    print OUT $str . "\n";
}

sub GetDescriptor {
    my ($d) = @_;
    foreach my $e (@{$doc->{CONCEPT}}) {
	if (exists($e->{DESCRIPTOR})) {
	    if ($e->{DESCRIPTOR} eq $d) { return $e; }
	}
    }
    # Shouldn't reach here!
    die "GetDescriptor failed to find entry it was told existed!\n";
}

sub PrintUsage {
    die $usage;
}
